home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / create_does < prev    next >
Encoding:
Text File  |  1991-09-21  |  1.4 KB  |  55 lines
  1. \ 00001 plb 9/21/91 Make ARRAY and CARRAY zero out memory, add WARRAY
  2.  
  3. decimal
  4.  
  5. -100 constant build-flag
  6.  
  7. variable 'pushreloc   ' quit 'pushreloc !
  8.  
  9. : does>  ( user stack: build-flag addr -- , poke address like 'THEN' )
  10.   us>  r@  us>   build-flag = not
  11.   IF    cr ." DOES> ... can't find CREATE keyword!"  quit
  12.   THEN  ( adr-to-poke abs-where-to-call -- )
  13.   here >r   swap  dp !    ( -- abs-called )
  14.   >rel  calladr,          ( -- )
  15.   last-sfa   ( -- sfa diff )  2+ $ 4000,0000 or  over @  ( -- sfa cnt <sfa> )
  16.   $ 3fff,0000 and  ( -- sfa cnt5 <sfa> )  or swap   !
  17.   r> dp !
  18.   r> drop ;
  19.  
  20. : CREATE  ( -- )   ( user stack:   -- build-flag address )
  21.   ( pushtos lit   hiword   loword   jsr   hiword   loword   rts )
  22.   (  2  +    2   +    2   +  2  +    2   +    2   +  2    +  2   = 16 )
  23.   :create  usp cell- usp !
  24.   ' (pushadr)  cfa,
  25.   build-flag >us  here >us
  26.   $ 4e75,4e75 ,  $ 4e75,4e75 ,
  27.   unsmudge
  28.   $ 4000,0006 CREATE_ID or   latest name> cell- !
  29. ;
  30.  
  31.  
  32. : CARRAY ( #bytes -- )
  33.   create  here swap even-up dup allot erase
  34.   does>   +     ;
  35.  
  36. : WARRAY  ( #cells -- , 00001 ) 
  37.   create  here swap 2* dup allot erase
  38.   does>   swap 2* +     ;
  39.   
  40. : ARRAY  ( #cells -- )
  41.   create  here swap cells dup allot erase
  42.   does>   swap cells +     ;
  43.  
  44. CREATE DON'T-USE-THIS  UNSMUDGE 
  45.     ' DON'T-USE-THIS  HERE - ABS CONSTANT DO-DOES-SIZE 
  46.  
  47. : >BODY  ( cfa -- pfa , CREATE-DOES child only!)
  48.   do-does-size +
  49. ;
  50.  
  51. : BODY>  ( pfa -- cfa , CREATE-DOES child only!)
  52.   do-does-size -
  53. ;
  54.  
  55.